home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-imgdec.adb < prev    next >
Text File  |  1996-01-30  |  12KB  |  353 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                    S Y S T E M . I M G _ D E C I M A L                   --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.4 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Img_Int; use System.Img_Int;
  27.  
  28. package body System.Img_Decimal is
  29.  
  30.    -------------------
  31.    -- Image_Decimal --
  32.    -------------------
  33.  
  34.    function Image_Decimal
  35.      (V     : Integer;
  36.       S     : access String;
  37.       Scale : Integer)
  38.       return  Natural
  39.    is
  40.       P : Natural := 0;
  41.  
  42.    begin
  43.       Set_Image_Decimal (V, S.all, P, Scale, 2, Integer'Max (1, Scale), 0);
  44.       return P;
  45.    end Image_Decimal;
  46.  
  47.    -----------------------
  48.    -- Set_Image_Decimal --
  49.    -----------------------
  50.  
  51.    procedure Set_Image_Decimal
  52.      (V     : Integer;
  53.       S     : out String;
  54.       P     : in out Natural;
  55.       Scale : Integer;
  56.       Fore  : Natural;
  57.       Aft   : Natural;
  58.       Exp   : Natural)
  59.    is
  60.       Digs : aliased String (1 .. Integer'Width);
  61.       --  Sign and digits of decimal value
  62.  
  63.       D : Natural;
  64.       --  Number of characters in Digs buffer
  65.  
  66.    begin
  67.       D := Image_Integer (V, Digs'Access);
  68.       Set_Decimal_Digits (Digs, D, S, P, Scale, Fore, Aft, Exp);
  69.    end Set_Image_Decimal;
  70.  
  71.    ------------------------
  72.    -- Set_Decimal_Digits --
  73.    ------------------------
  74.  
  75.    procedure Set_Decimal_Digits
  76.      (Digs  : in out String;
  77.       NDigs : Natural;
  78.       S     : out String;
  79.       P     : in out Natural;
  80.       Scale : Integer;
  81.       Fore  : Natural;
  82.       Aft   : Natural;
  83.       Exp   : Natural)
  84.    is
  85.       Minus : constant Boolean := (Digs (1) = '-');
  86.       --  Set True if input is negative
  87.  
  88.       Zero : Boolean := (Digs (2) = '0');
  89.       --  Set True if input is exactly zero (only case when a leading zero
  90.       --  is permitted in the input string given to this procedure). This
  91.       --  flag can get set later if rounding causes the value to become zero.
  92.  
  93.       FD : Natural := 2;
  94.       --  First digit position of digits remaining to be processed
  95.  
  96.       LD : Natural := NDigs;
  97.       --  Last digit position of digits remaining to be processed
  98.  
  99.       ND : Natural := NDigs - 1;
  100.       --  Number of digits remaining to be processed (LD - FD + 1)
  101.  
  102.       Digits_Before_Point : Integer := ND - Scale;
  103.       --  Number of digits before decimal point in the input value. This
  104.       --  value can be negative if the input value is less than 0.1, so
  105.       --  it is an indication of the current exponent. Digits_Before_Point
  106.       --  is adjusted if the rounding step generates an extra digit.
  107.  
  108.       After : constant Natural := Integer'Max (1, Aft);
  109.       --  Digit positions after decimal point in result string
  110.  
  111.       Expon : Integer;
  112.       --  Integer value of exponent
  113.  
  114.       RP : Integer;
  115.       --  Position for rounding in no exponent case
  116.  
  117.       procedure Round (N : Natural);
  118.       --  Round the number in Digs. N is the position of the last digit to be
  119.       --  retained in the rounded position (rounding is based on Digs (N + 1)
  120.       --  FD, LD, ND are reset as necessary if required. Note that if the
  121.       --  result value rounds up (e.g. 9.99 => 10.0), an extra digit can be
  122.       --  placed in the sign position as a result of the rounding, this is
  123.       --  the case in which FD is adjusted.
  124.  
  125.       procedure Set (C : Character);
  126.       pragma Inline (Set);
  127.       --  Sets character C in output buffer
  128.  
  129.       procedure Set_Blanks_And_Sign (N : Integer);
  130.       --  Sets leading blanks and minus sign if needed. N is the number of
  131.       --  positions to be filled (a minus sign is output even if N is zero
  132.       --  or negative, but for a positive value, if N is non-positive, then
  133.       --  the call has no effect).
  134.  
  135.       procedure Set_Digits (S, E : Natural);
  136.       pragma Inline (Set_Digits);
  137.       --  Set digits S through E from Digs, no effect if S > E
  138.  
  139.       procedure Set_Zeroes (N : Integer);
  140.       pragma Inline (Set_Zeroes);
  141.       --  Set N zeroes, no effect if N is negative
  142.  
  143.       procedure Round (N : Natural) is
  144.          D : Character;
  145.  
  146.       begin
  147.          --  Nothing to do if rounding at or past last digit
  148.  
  149.          if N >= LD then
  150.             return;
  151.  
  152.          --  Cases of rounding before the initial digit
  153.  
  154.          elsif N < FD then
  155.  
  156.             --  The result is zero, unless we are rounding just before
  157.             --  the first digit, and the first digit is five or more.
  158.  
  159.             if N = 1 and then Digs (2) >= '5' then
  160.                Digs (1) := '1';
  161.             else
  162.                Digs (1) := '0';
  163.                Zero := True;
  164.             end if;
  165.  
  166.             Digits_Before_Point := Digits_Before_Point + 1;
  167.             FD := 1;
  168.             LD := 1;
  169.             ND := 1;
  170.  
  171.          --  Normal case of rounding an existing digit
  172.  
  173.          else
  174.             LD := N;
  175.             ND := LD - 1;
  176.  
  177.             if Digs (N + 1) >= '5' then
  178.                for J in reverse 2 .. N loop
  179.                   D := Character'Succ (Digs (J));
  180.  
  181.                   if D <= '9' then
  182.                      Digs (J) := D;
  183.                      return;
  184.                   else
  185.                      Digs (J) := '0';
  186.                   end if;
  187.                end loop;
  188.  
  189.                --  Here the rounding overflows into the sign position. That's
  190.                --  OK, because we already captured the value of the sign and
  191.                --  we are in any case destroying the value in the Digs buffer
  192.  
  193.                Digs (1) := '1';
  194.                FD := 1;
  195.                ND := ND + 1;
  196.                Digits_Before_Point := Digits_Before_Point + 1;
  197.             end if;
  198.          end if;
  199.       end Round;
  200.  
  201.       procedure Set (C : Character) is
  202.       begin
  203.          P := P + 1;
  204.          S (P) := C;
  205.       end Set;
  206.  
  207.       procedure Set_Blanks_And_Sign (N : Integer) is
  208.          W : Integer := N;
  209.  
  210.       begin
  211.          if Minus then
  212.             W := W - 1;
  213.             Set ('-');
  214.          end if;
  215.  
  216.          for J in 1 .. W loop
  217.             Set (' ');
  218.          end loop;
  219.       end Set_Blanks_And_Sign;
  220.  
  221.       procedure Set_Digits (S, E : Natural) is
  222.       begin
  223.          for J in S .. E loop
  224.             Set (Digs (J));
  225.          end loop;
  226.       end Set_Digits;
  227.  
  228.       procedure Set_Zeroes (N : Integer) is
  229.       begin
  230.          for J in 1 .. N loop
  231.             Set ('0');
  232.          end loop;
  233.       end Set_Zeroes;
  234.  
  235.    --  Start of processing for Set_Decimal_Digits
  236.  
  237.    begin
  238.       --  Case of exponent given
  239.  
  240.       if Exp > 0 then
  241.          Set_Blanks_And_Sign (Fore - 1);
  242.          Round (Aft + 2);
  243.          Set (Digs (FD));
  244.          FD := FD + 1;
  245.          ND := ND - 1;
  246.          Set ('.');
  247.  
  248.          if ND >= After then
  249.             Set_Digits (FD, FD + After - 1);
  250.  
  251.          else
  252.             Set_Digits (FD, LD);
  253.             Set_Zeroes (After - ND);
  254.          end if;
  255.  
  256.          --  Calculate exponent. The number of digits before the decimal point
  257.          --  in the input is Digits_Before_Point, and the number of digits
  258.          --  before the decimal point in the output is 1, so we can get the
  259.          --  exponent as the difference between these two values. The one
  260.          --  exception is for the value zero, which by convention has an
  261.          --  exponent of +0.
  262.  
  263.          if Zero then
  264.             Expon := 0;
  265.          else
  266.             Expon := Digits_Before_Point - 1;
  267.          end if;
  268.  
  269.          Set ('E');
  270.          ND := 0;
  271.  
  272.          if Expon >= 0 then
  273.             Set ('+');
  274.             Set_Image_Integer (Expon, Digs, ND);
  275.          else
  276.             Set ('-');
  277.             Set_Image_Integer (-Expon, Digs, ND);
  278.          end if;
  279.  
  280.          Set_Zeroes (Exp - ND - 1);
  281.          Set_Digits (1, ND);
  282.          return;
  283.  
  284.       --  Case of no exponent given. To make these cases clear, we use
  285.       --  examples. For all the examples, we assume Fore = 2, Aft = 3.
  286.       --  A P in the example input string is an implied zero position,
  287.       --  not included in the input string.
  288.  
  289.       else
  290.          --  Round at correct position
  291.          --    Input: 4PP      => unchanged
  292.          --    Input: 400.03   => unchanged
  293.          --    Input  3.4567   => 3.457
  294.          --    Input: 9.9999   => 10.000
  295.          --    Input: 0.PPP5   => 0.PP1
  296.          --    Input: 0.PPP4   => 0
  297.          --    Input: 0.00003  => 0
  298.  
  299.          Round (LD - (Scale - After));
  300.  
  301.          --  No digits before point in input
  302.          --    Input: .123   Output: 0.123
  303.          --    Input: .PP3   Output: 0.003
  304.  
  305.          if Digits_Before_Point <= 0 then
  306.             Set_Blanks_And_Sign (Fore - 1);
  307.             Set ('0');
  308.             Set ('.');
  309.  
  310.             Set_Zeroes (After - ND);
  311.             Set_Digits (FD, LD);
  312.  
  313.          --  At least one digit before point in input
  314.  
  315.          else
  316.             Set_Blanks_And_Sign (Fore - Digits_Before_Point);
  317.  
  318.             --  Less digits in input than are needed before point
  319.             --    Input: 1PP  Output: 100.000
  320.  
  321.             if FD + Digits_Before_Point - 1 > LD then
  322.                Set_Digits (FD, LD);
  323.                Set_Zeroes (FD + Digits_Before_Point - 1 - LD);
  324.                Set ('0');
  325.                Set_Zeroes (After);
  326.  
  327.             --  Input has full amount of digits before decimal point
  328.  
  329.             else
  330.                Set_Digits (FD, FD + Digits_Before_Point - 1);
  331.                Set ('.');
  332.  
  333.                --  Input does not have full amount of digits after point
  334.                --    Input: 123.4  Output: 123.400
  335.  
  336.                if LD < FD + Digits_Before_Point then
  337.                   Set_Digits (FD + Digits_Before_Point, LD);
  338.                   Set_Zeroes (FD + Digits_Before_Point - LD);
  339.  
  340.                --  Input has full amount of digits before and after point
  341.                --    Input: 123.345  Output: 123.345
  342.  
  343.                else
  344.                   Set_Digits (FD + Digits_Before_Point, LD);
  345.                end if;
  346.             end if;
  347.          end if;
  348.       end if;
  349.  
  350.    end Set_Decimal_Digits;
  351.  
  352. end System.Img_Decimal;
  353.